home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Grab Bag
/
Shareware Grab Bag.iso
/
007
/
boostrs.arc
/
CALHEAP.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1985-11-03
|
4KB
|
132 lines
{ ---------------------------------
CALHEAP for given month and year
--------------------------------- }
Procedure CalHeap ( Page : HeapBuf; MM, CCYY, StartCol, StartRow : Integer);
var
target : string[10];
year : string[4];
PreviousMonth,
NextMonth,
PreviousMonthLength,
NumDays,
Xpos, Ypos, StartDay,
i, j, day : integer;
Temp, Months,
Col, Row : AnyString;
const
days : array[1..7] of string[2] =
('Su','Mo','Tu','We','Th','Fr','Sa');
MonthLength : array[1..12] of integer =
(31,28,31,30,31,30,31,31,30,31,30,31);
begin
target := strip( dows ( mm, 1, ccyy), ' ');
day := 0;
repeat
day := succ(day);
until (Copy ( target, 1, 2) = days[day]) or (day > 7);
if day <= 7 then
begin
Col := #179+#197;
Col := #194+Col+Col+Col+Col+Col+#179+#193;
Row := #196+#196+#197;
Row := #195+Row+Row+Row+Row+Row+Row+#196+#196+#180;
BoxHeap ( Page, StartCol, StartRow+2, StartCol+21, StartRow+14, 1, 14);
for i := 0 to 5 do
PutHeap ( Page, V, Col, StartCol+3+i*3, StartRow+2, 14);
for i := 0 to 4 do
PutHeap ( Page, H, Row, StartCol, StartRow+4+i*2, 14);
Months := 'January February March '+
'April May June '+
'July August September '+
'October November December ';
Str (CCYY,year);
Temp := Copy ( Months, 1+(MM-1)*10, 10);
Temp := Center ( Strip ( Temp, ' ') + ', '+year ,20,' ');
PutHeap (Page, H, Temp , StartCol + 1, StartRow, 14);
for i := 1 to 7 do
PutHeap (Page, H,days[i] + ' ',
StartCol+1+(i-1)*3, StartRow+1, 10);
if MM = 1 then
PreviousMonth := 12
else
PreviousMonth := MM - 1;
PreviousMonthLength := MonthLength[PreviousMonth];
if ( PreviousMonth = 2 ) and ( Abs(1980-CCYY) mod 4 = 0) then
PreviousMonthLength := succ(PreviousMonthLength);
Ypos := StartRow + 3;
if day > 1 then
begin
j := PreviousMonthLength - day + 1;
for i := 1 to day - 1 do
begin
j := succ(j);
str ( j:2, Temp);
PutHeap ( Page, H, Temp , StartCol+1+(i-1)*3, Ypos, 12);
end;
for i := 1 to 7 - day + 1 do
begin
str ( i:2, Temp);
PutHeap ( Page, H, Temp , StartCol+1+(day-1)*3+(i-1)*3, Ypos, 14);
end;
end { day > 1 }
else
begin
j := PreviousMonthLength - 7;
for i := 1 to 7 do
begin
j := succ(j);
str ( j:2, Temp);
PutHeap ( Page, H, Temp , StartCol+1+(i-1)*3, Ypos, 12);
end;
end { day = 1 };
j := 0;
Ypos := StartRow + 5;
NumDays := MonthLength[mm];
if ( MM = 2 ) and ( Abs(1980-CCYY) mod 4 = 0) then
NumDays := succ(NumDays);
if Day > 1 then
StartDay := 7 - day + 2
else
StartDay := 1;
for i := StartDay to NumDays do
begin
Xpos := StartCol+1+j*3;
Str(i:2,Temp);
PutHeap ( Page, H, Temp, Xpos, Ypos, 14);
j := succ(j);
if j = 7 then
begin
j := 0;
Ypos := Ypos + 2;
end;
end;
if Day > 1 then
NextMonth := 42 - ( day - 1 + NumDays)
else
NextMonth := 42 - (NumDays + 7);
for i := 1 to NextMonth do
begin
Xpos := StartCol+1+j*3;
Str(i:2,Temp);
PutHeap ( Page, H, Temp, Xpos, Ypos, 12);
j := succ(j);
if j = 7 then
begin
j := 0;
Ypos := Ypos + 2;
end;
end;
end;
end { CalHeap };